perm filename UNITRE.NEW[1,JRA] blob
sn#028943 filedate 1973-03-08 generic text, type T, neo UTF8
00002 (DE RESUNITP(P TM L)(PROG (Z)
00004 A(SETQ Z(CDADAR L))
00006 (COND((EQ(CAR Z) P)(GO C)))
00008 B(SETQ L(CDR L))
00010 (COND(L(GO A)))
00012 (RETURN NIL)
00014 C(COND((UNIFY(CDR Z) TM)(RETURN(LIST NIL))))
00016 (GO B)))
00018
00020 (DE RESUNITN(P TM L)
00022 (PROG (Z)
00024 A(SETQ Z(CADAR L))
00026 (COND((EQ(CAR Z)P)(GO C)))
00028 B(SETQ L(CDR L))
00030 (COND(L(GO A)))
00032 (RETURN NIL)
00034 C(COND((UNIFY(CDR Z)TM)(RETURN(LIST NIL))))
00036 (GO B)))
00038
00100
00200
00300 (DEFPROP UNITRES
00400 (LAMBDA(C UP UN)
00500 (PROG (C1 Z1 U Z RES)
00600 (SETQ C1 C)
00700 (COND ((AND (ALLPOS C) (NULL UN)) (RETURN NIL)) ((AND (ALLNEG C) (NULL UP)) (RETURN NIL)))
00750 (COND((UNIT C)(RETURN(COND((ALLPOS C)(RESUNITP(CAADR C)(CDADR C)UN))
00775 (T(RESUNITN(CADADR C)(CDDADR C)UP)))) ))
00800 (COND ((NULL UN) (SETQ C (NEGL C)) (GO N)))
00900 (SETQ C (CDR C))
01000 B (SETQ Z1 (CAR C))
01100 (COND ((NEG Z1) (GO N)))
01200 (SETQ U UN)
01300 A (COND ((NOT (EQ (CAR Z1) (CADADR (CAR U)))) (GO A1)))
01400 (SETQ Z (UNI (CDDADR (CAR U)) (CDR Z1) NIL))
01500 (COND ((NULL Z) (GO A1)))
01600 (COND ((NULL Z) (GO A1)) ((UNIT C1) (RETURN (LIST NIL))))
01700 (SETQ RES (CONS (REDUCER C1 C) RES))
01800 (GO A2)
01900 A1 (SETQ U (CDR U))
02000 (COND (U (GO A)))
02100 A2 (SETQ C (CDR C))
02200 (COND (C (GO B)) (T (RETURN RES)))
02300 N (SETQ Z1 (CDAR C))
02400 (SETQ U UP)
02500 C (COND ((NULL U) (RETURN RES)))
02600 C2 (COND ((NOT (EQ (CAR Z1) (CAADAR U))) (GO C1)))
02700 (SETQ Z (UNI (CDADAR U) (CDR Z1) NIL))
02800 (COND ((NULL Z) (GO C1)) ((UNIT C1) (RETURN (LIST NIL))))
02900 (SETQ RES (CONS (REDUCER C1 C) RES))
03000 (GO C3)
03100 C1 (SETQ U (CDR U))
03200 (COND (U (GO C2)))
03300 C3 (SETQ C (CDR C))
03400 (COND (C (GO N)) (T (RETURN RES)))))
03500 EXPR)